home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 038a / aplibs91.zip / FENTRY-U.BAS < prev    next >
BASIC Source File  |  1991-05-17  |  27KB  |  915 lines
  1.  
  2.  
  3.  
  4. '==============================================================================
  5. '      HB'S ALL-PURPOSE LIBRARY, FORMATTED ENTRY UNIT -- FENTRY-U.BAS
  6. '==============================================================================
  7. '                                                               -- 2-13-90
  8.                             $COMPILE UNIT
  9.                             $ERROR ALL OFF
  10.  
  11.  
  12.  DEFINT A-Z
  13.  
  14.  %False = 0
  15.  %True = NOT %False
  16.  %ReadRodent = 3
  17.  %LeftButton = 1
  18.  %RightButton = 2
  19.  %MaxDecPlaces = 4
  20.  %Center = 0
  21.  
  22.  %SkipGhostMouse = %True
  23.  
  24.  EXTERNAL RD$, ColorDisplay, NeedDCon, SoundOn
  25.  EXTERNAL BoxColor, FldColor, WinColor, ScrColor
  26.  EXTERNAL CursorTop, CursorBottom, Ln, Col
  27.  EXTERNAL PressAKeyBeep$, OopsBeep$, TinyBeep$
  28.  EXTERNAL LocalAreaCode$,InsertStatus, Record%
  29.  
  30.  SHARED AdvanceCursor
  31.  
  32.  DECLARE FUNCTION FigDate& (STRING)
  33.  DECLARE FUNCTION WriteDate$ (LONG)
  34.  DECLARE FUNCTION GetDate$ ()
  35.  
  36.  DECLARE SUB CloseFiles ()
  37.  DECLARE SUB Mouse (INTEGER, INTEGER, INTEGER, INTEGER)
  38.  DECLARE SUB BOXMESSAGE2 (INTEGER, INTEGER, INTEGER, STRING ARRAY,_
  39.                                                            INTEGER, INTEGER)
  40.  DECLARE SUB SCREENPUSH ()
  41.  DECLARE SUB SCREENPOP ()
  42.  DECLARE SUB Marker (string)
  43.  
  44.  
  45.  
  46. SUB ENTERSTRING (Wkg$,FLength,Msg$) PUBLIC
  47.  
  48. '   WHAT IS THIS ?? This routine provides a field right at the present cursor
  49. '         location for the operator to enter something into (if it starts off
  50. '         blank) or edit. Wkg$ is the current value of the field.  FLength =
  51. '         length of field.
  52. '
  53. '         Msg$ may be "" or may hold the strings "Cap" for all uppercase,
  54. '         "Auto" to automatically go on when the field is full, "UpOut" or
  55. '         "BackOut" if UpArrow or Left/ backspace keys are to be able to end
  56. '         entry; also may include "Ins" to start up in the insert mode, and/or
  57. '         "-" if the minus sign is allowed to be entered.
  58. '
  59. '         Active keys also include:  ^Y to clear the line
  60. '                                    ^T to delete one word (to right)
  61. '                                    ^U to undo (restore original string)
  62. '                                     Home, End, cursor rt/left,
  63. '                                    ^cursor (jumps to beginning of a word)
  64. '
  65. '         If there is something in the field to begin with and the operator
  66. '         starts typing something else, the field clears. If the cursor is
  67. '         moved around first, that doesn't happen.
  68. '
  69. '         On exiting sub, Msg$ will be reset as "Left", "Auto", "Up", "Down",
  70. '         "HELP!", "F2", "ESC" or "CR", "Tab" or "ShfTab" according to what
  71. '         event terminated the entry process. At any time during string entry
  72. '         the operator can press [CR] or DOWN-ARROW to enter & go on; [F2] can
  73. '         be pressed  (I use F2 for Database Function commands  -- Clear,
  74. '         Find, Next/Prev, Save etc.) or F1 can also be made active (for a
  75. '         help key) ...
  76.  
  77. '         UPDATE NOTE 11-90: InsertStatus is now an external var so it
  78. '         remains on or off from data field to data field.
  79.  
  80.  
  81.   LOCAL Fpos, Masq$,Starting$, Numeric, Auto, Caps, UpOut, BackOut, K$,_
  82.        NoNeg,  Z, NumKStrokes, StartWord, EndWord, Done
  83.  
  84.  
  85.  Wkg$ = LEFT$ (Wkg$, FLength)
  86.  Starting$ = Wkg$ '                                    save starting string --
  87.   Ln = CSRLIN: Col = POS
  88. '                                         Scan the Option String for Codes ...
  89. '                                                and set flags accordingly
  90.  Numeric = INSTR (UCASE$ (Msg$),"NUM")
  91.  Auto = INSTR (UCASE$ (Msg$),"AUTO")
  92.  Caps = INSTR (UCASE$ (Msg$),"CAP")
  93.  UpOut = INSTR (UCASE$ (Msg$),"UPOUT")
  94.  BackOut = INSTR (UCASE$ (Msg$),"BACKOUT")
  95.  IF INSTR (Msg$, "-") = 0 THEN NoNeg = %True
  96.  
  97.  IF FLength > 1 THEN
  98.     Masq$ = "\"+SPACE$(FLength-2)+"\"
  99.  ELSEIF FLength = 1 THEN
  100.     Masq$ = "!"
  101.  ELSE
  102.     PRINT "SETUP ERROR -- STRING FIELD HAS LENGTH < 1 !!"
  103.     Done = %True
  104.  END IF
  105.  
  106.  FPos = 1 + AdvanceCursor    '                    this simulates a part-full
  107.  NumKStrokes = AdvanceCursor '                    field. Used in ROTADATE.
  108.  
  109. '                   ============ WRITE THE FIELD TO DISPLAY =============
  110.  DO UNTIL Done
  111.  
  112.    LOCATE Ln, Col,0 '
  113.    IF Wkg$ = "" THEN  Wkg$ = " "  '                            print the string
  114.    PRINT USING Masq$;Wkg$
  115. '                                    now, if you already pressed Up or ShfTab,
  116. '                                    we'll exit after printing restored line
  117.    IF Msg$ = "Up" OR Msg$ = "ShfTab" THEN EXIT LOOP
  118. '                      if "auto-CR" is on and we have reached the end, quit ...
  119.    IF Auto AND FPos > FLength THEN Msg$ = "Auto": EXIT LOOP
  120. '                     if there are trailing spaces, get rid of them
  121. '                     unless the cursor is out to the right of the last chr ...
  122.    IF FPos =< LEN(Wkg$) THEN Wkg$ = RTRIM$(Wkg$)
  123.  
  124.  '                 ================== SET CURSOR: ===========================
  125.  
  126.    IF ColorDisplay THEN
  127.      LOCATE Ln,(Col+FPos-1),1,(6+2*InsertStatus),7
  128.    ELSE
  129.      LOCATE Ln,(Col+FPos-1),1,(11+4*InsertStatus),12
  130.    END IF
  131.  
  132.    DO:LOOP UNTIL INSTAT '                   ****************************
  133.    K$ = INKEY$  '                          **   RECEIVE KEYPRESS ...   **
  134.  '                                          ****************************
  135.  
  136.  
  137.    INCR NumKStrokes
  138.  
  139.  
  140.    SELECT CASE K$
  141.  
  142.       CASE CHR$(0)+CHR$(&H48)
  143.          GOSUB EUpArrow
  144.          IF Done THEN EXIT LOOP
  145.  
  146.       CASE CHR$(0)+CHR$(&H4B)
  147.          GOSUB ELeftArrow
  148.          IF Done THEN EXIT LOOP
  149.  
  150.       CASE CHR$(0)+CHR$(&H4D)
  151.          GOSUB ERightArrow
  152.          IF Done THEN EXIT LOOP
  153.  
  154.       CASE CHR$(0)+CHR$(&H50)
  155.          GOSUB EDownArrow
  156.          IF Done THEN EXIT LOOP
  157.  
  158.       CASE CHR$(0)+CHR$(&H47)
  159.          GOSUB EHomeKey
  160.  
  161.       CASE CHR$(0)+CHR$(&H4F)
  162.          GOSUB EEndKey
  163.  
  164.       CASE CHR$(0)+CHR$(&H53)
  165.          GOSUB EDelKey
  166.  
  167.       CASE CHR$(0)+CHR$(&H52)
  168.          GOSUB EInsKey
  169.  
  170.       CASE CHR$(0)+CHR$(&H3B)
  171.          GOSUB EF1Key
  172.          IF Done THEN EXIT LOOP
  173.  
  174.       CASE CHR$(0)+CHR$(&H3C)
  175.          GOSUB EF2Key
  176.          IF Done THEN EXIT LOOP
  177.  
  178.       CASE CHR$(0)+CHR$(115)
  179.          GOSUB ECtrlLeftKey
  180.  
  181.       CASE CHR$(0)+CHR$(116)
  182.          GOSUB ECtrlRightKey
  183.  
  184.       CASE CHR$(13)                'you pressed [CR]: exit w/ resulting string
  185.         Msg$ = "CR"
  186.         EXIT LOOP
  187.  
  188.       CASE CHR$(8) '                                    You pressed [BACKSPACE].
  189.          DECR FPos '                                    back up 1 space;
  190.          IF FPos < 1 THEN '                                if cursor is trying
  191.            IF BackOut THEN '                           to get out the left side
  192.              Msg$ = "Left" '                             of the box and BackOut
  193.              EXIT LOOP '                                  is on, then exit;
  194.            ELSE
  195.              FPos = 1  '                      otherwise place it at position #1
  196.            END IF
  197.          ELSE
  198.            GOSUB EDelKey '                                else delete character.
  199.          END IF
  200.  
  201.       CASE CHR$(27)                    ' you pressed [ESC]: exit
  202.          Msg$ = "ESC"
  203.          EXIT LOOP
  204.  
  205.       CASE CHR$(9)                    ' you pressed [TAB]: exit
  206.          Msg$ = "Tab"
  207.          EXIT LOOP
  208.  
  209.       CASE CHR$(0) + CHR$(15)                    ' you pressed [ShfTAB]: exit
  210.          Msg$ = "ShfTab"
  211.          EXIT LOOP
  212.  
  213.       CASE CHR$(20)
  214.          StartWord = FPos
  215.          DO UNTIL MID$ (Wkg$,StartWord,1) = " " OR StartWord = 1
  216.            DECR StartWord
  217.          LOOP
  218.          EndWord = FPos
  219.          DO
  220.            INCR EndWord
  221.          LOOP UNTIL MID$ (Wkg$,EndWord,1) = " " OR EndWord > LEN(Wkg$)
  222.          Wkg$ = LEFT$ (Wkg$, StartWord-1) + MID$ (Wkg$, EndWord)
  223.          IF LEFT$(Wkg$,1) = " " THEN Wkg$ = MID$(Wkg$,2)
  224.          FPos = StartWord
  225.  
  226.       CASE CHR$(25)   '                                      you pressed ^Y
  227.          Wkg$ = ""
  228.          FPos = 1
  229.  
  230.       CASE CHR$(21)   '                                      you pressed ^U
  231.          Wkg$ = Starting$
  232.          FPos = 1
  233.  
  234.  CASE ELSE '                                       some other key was pressed.
  235.  
  236.  IF FPos <= FLength _
  237.     AND NOT (InsertStatus=%True AND (LEN(Wkg$) => FLength) AND NumKStrokes >1)_
  238.       THEN
  239.  
  240. '  if field isn't full yet, or
  241. '  if it is, you don't have 'insert' on, unless this is the first keystroke ...
  242. '                                                          (whew !!)
  243.  
  244. '                                                  INS is off, or just starting
  245.    IF  NumKStrokes = 1 THEN Wkg$ = ""
  246.                                '  this zaps the old entry if you
  247.         SELECT CASE ASC(K$) '                        start a new one ...
  248.            CASE 1 TO 31, >126
  249.              K$ = "": EXIT SELECT '                  eliminate invalid chrs ...
  250.            CASE 32 TO 44, 47, >57
  251.              IF Numeric THEN PLAY "O3 A64":K$ = "": EXIT SELECT
  252.            CASE 45
  253.              IF Numeric AND NoNeg THEN PLAY "O3 A64":K$ = "": EXIT SELECT
  254.        END SELECT
  255.        IF Caps THEN K$ = UCASE$(K$)
  256.        IF FPos > LEN(Wkg$) THEN
  257.  
  258.              DO WHILE FPos-LEN(Wkg$) > 1: Wkg$ = Wkg$ + " ": LOOP
  259. '                                                add spaces out to cursor pos.
  260.              Wkg$=Wkg$+K$ '                             ...  and tack on K$
  261.  
  262.      ELSE
  263.              Wkg$ = LEFT$(Wkg$,FPos-1)+K$+MID$(Wkg$,FPos+1+InsertStatus)
  264.      END IF
  265.     '                               the long line plugs K$ in -- the hard way!
  266.      IF K$ <> "" THEN INCR FPos
  267.  
  268.    ELSE  '                            else,  the line is full and Auto is off
  269.  
  270.         PLAY "O0 A64"  '              so we ignore the keystroke & just Beep
  271.  
  272.    END IF
  273.  
  274.  END SELECT
  275.  
  276.  LOOP
  277.  
  278. '                           ***************** END OF MAIN LOOP
  279.  
  280.  LOCATE ,,1,CursorTop,CursorBottom
  281.  AdvanceCursor = 0
  282.  EXIT SUB
  283.  
  284. ELeftArrow:
  285.   IF FPos > 1 THEN
  286.     FPos = FPos - 1
  287.   ELSE
  288.     IF BackOut THEN
  289.        Msg$ = "Left"
  290.        Done = %True
  291.     END IF
  292.   END IF
  293.   RETURN
  294.  
  295. ERightArrow:
  296.   IF FPos =< FLength THEN
  297.     INCR FPos
  298.   ELSEIF Auto THEN
  299.     Msg$ = "Auto"
  300.     Done = %True '                                 if Auto is on then exit
  301.   END IF
  302.   RETURN
  303.  
  304. EInsKey:
  305.   IF InsertStatus = %False THEN
  306.     InsertStatus = %True
  307.   ELSE
  308.     InsertStatus = %False
  309.   END IF
  310.   RETURN
  311.  
  312. EDelKey:
  313.   IF FPos = 1 THEN Wkg$ = MID$(Wkg$,2): RETURN
  314.   IF FPos = LEN(Wkg$) THEN
  315.     Wkg$ = LEFT$ (Wkg$, FPos-1)
  316.   ELSEIF FPos < LEN(Wkg$) THEN
  317.     Wkg$ = LEFT$(Wkg$, FPos-1) + MID$(Wkg$, FPos+1)
  318.   END IF
  319. '                                              (if FPos > LEN don't do nothin')
  320.   RETURN
  321.  
  322. EHomeKey:
  323.   FPos = 1
  324.   RETURN
  325.  
  326. EEndKey:
  327.   FPos = LEN(Wkg$)+1
  328.   RETURN
  329.  
  330. ECtrlLeftKey:
  331.  IF FPos > 1 THEN DECR FPos
  332.  DO UNTIL FPos = 1
  333.    DECR FPos
  334.  LOOP UNTIL MID$ (Wkg$,FPos,1) = " "
  335.  IF FPos > 1 THEN INCR FPos
  336.  RETURN
  337.  
  338. ECtrlRightKey:
  339.  DO
  340.    INCR FPos
  341.  LOOP UNTIL MID$ (Wkg$,FPos,1) = " " OR FPos > LEN (Wkg$)
  342.  INCR FPos
  343.  FPos = MIN (FPos, LEN(Wkg$)+1)
  344.  RETURN
  345.  
  346. EUpArrow:
  347.   IF UpOut THEN
  348. ''''''    IF LTRIM$ (Wkg$) <> "" THEN Wkg$ = Starting$
  349.     Msg$ = "Up"
  350.   END IF
  351.   RETURN
  352.  
  353. EDownArrow:
  354.   Msg$ = "Down"
  355.   Done = %True
  356.   RETURN
  357.  
  358.  
  359. EF1Key:
  360.  IF INSTR (Msg$, "F1") THEN
  361.    Msg$ = "HELP!"
  362.    Done = %True
  363.  END IF
  364.  RETURN
  365.  
  366.  
  367. EF2Key:
  368.  IF INSTR (Msg$, "F2") THEN
  369.    Msg$ = "F2"
  370.    Done = %True
  371.  END IF
  372.  RETURN
  373.  
  374.  END SUB                                              REM: ENTERSTRING
  375.  
  376. ' -------------------------------------------------------------------
  377. SUB ENTERNUMBER  (Wkg#, Masq$, Msg$) PUBLIC '          note: Shell for
  378. '                                                                ENTERSTRING
  379. '   =======                This the routine to enter a number onscreen. It
  380. '                          makes the value into a string if <> 0 and calculates
  381. '                          the field length based on Masq$.  Msg$ is simply
  382. '                          passed without much alteration to ENTERSTRING.
  383.  
  384.  LOCAL Wkg$, FLength, DecPlaces
  385.  
  386.  IF VERIFY (Masq$, "#.-$! ") THEN
  387.    COLOR 15, 0
  388.    BEEP: PRINT "ENTERNUMBER: MASK STRING ERROR": DELAY 3: EXIT SUB
  389.  END IF
  390.  
  391.  IF INSTR (Masq$, ".") THEN
  392.    DecPlaces = TALLY (MID$ (Masq$, INSTR (Masq$, ".")), "#")
  393.  ELSE
  394.    DecPlaces = 0
  395.  END IF
  396.  Wkg# = ROUNDOFF# (Wkg#, DecPlaces)
  397.  
  398.  Ln = CSRLIN: Col = POS
  399.  FLength = LEN (Masq$)
  400.  Msg$ = "Num" + Msg$
  401.  
  402.  IF Wkg# = 0 THEN
  403.     Wkg$ = ""
  404.  ELSE
  405.     Wkg$ = LTRIM$ (STR$(Wkg#))'     set working $.
  406.  END IF
  407.  
  408.  IF INSTR (Wkg$,".") THEN            '                strip trailing zeroes ...
  409.    Wkg$ = LEFT$(Wkg$,INSTR(Wkg$,".")+4)
  410.    Wkg$ = RTRIM$ (Wkg$, "0")
  411.    Wkg$ = RTRIM$ (Wkg$, ".")
  412.  END IF
  413.  
  414. '                       -----------------------------------
  415.  
  416.                         CALL ENTERSTRING(Wkg$,FLength,Msg$)
  417.  
  418. '                       -----------------------------------
  419.  
  420.  Wkg# = VAL(Wkg$) '                                              reset Wkg# ...
  421.  Wkg# = ROUNDOFF# (Wkg#, DecPlaces)
  422.  LOCATE Ln, Col: PRINT USING Masq$; Wkg# '                            print it
  423. '         ...
  424.  
  425. END SUB                                                         REM ENTERNUMBER
  426.  
  427. ' -------------------------------------------------------------------
  428.  
  429. SUB ENTERDATE  (A$, Msg$) PUBLIC
  430.  
  431.  LOCAL L,C
  432.  IF INSTR (Msg$, "N/A") THEN OKToReturnNA = %True
  433.  
  434. '                                           set up to use the formatted entry
  435. EnterDate1: '                                routine ENTERBUNCHES with 3 blank
  436.  L = CSRLIN: C = POS '                      fields to fill and 2 hyphens
  437.  DATA 2,"-",2,"-",2,"END"
  438.  RESTORE EnterDate1
  439.  Msg$ = Msg$ + "Num"
  440.  
  441.    CALL ENTERBUNCHES(A$, Msg$)
  442. '                                          now check the result for being a
  443. '                                          valid date (FnFigDate& returns > 0)
  444.  
  445.  IF (Msg$ = "CR" OR Msg$ = "Auto") AND FigDate& (A$) = 0 THEN
  446.     IF OKToReturnNA THEN
  447.       A$ = "  N/A   "
  448.     ELSE
  449.       A$ = "": LOCATE L,C: GOTO EnterDate1
  450.     END IF
  451.  END IF
  452.  
  453.  LOCATE L, C: PRINT A$
  454. END SUB
  455.  
  456. ' -------------------------------------------------------------------
  457. SUB RotaDate  (D$,Msg$) PUBLIC
  458.  LOCAL L, C, K$, I$(), UseF1, UseF2
  459.  DIM I$ (3)
  460.  
  461.  L = CSRLIN: C = POS
  462.  IF INSTR (Msg$, "F1") THEN UseF1 = -1
  463.  IF INSTR (Msg$, "F2") THEN UseF2 = -1
  464.  
  465.  COLOR BoxColor MOD 16, BoxColor \ 16
  466.  I$(1) = "To enter date shown press [CR]."
  467.  I$(2) = " Use ["+CHR$(27)+"] or ["+CHR$(26)+"] to change."
  468.  I$(3) = "You can also do a normal keyboard entry"
  469.  CALL SCREENPUSH
  470.  IF L < 19 THEN BoxTopLine = 25 ELSE BoxTopLine = 5
  471.  CALL BOXMESSAGE2 (BoxTopLine, %Center, 0, I$(), 3, 47)
  472.  
  473.  LOCATE L+1,C+2 '                                         print double arrow
  474.  PRINT CHR$(17);CHR$(205);CHR$(205);CHR$(16)
  475.  
  476.  COLOR FldColor MOD 16, FldColor \ 16
  477.  DO
  478.    LOCATE L,C: PRINT D$;
  479.    DO:LOOP UNTIL INSTAT
  480.    K$ = INKEY$
  481.    IF LEN(K$) < 2 THEN
  482.      IF K$ = CHR$(13) THEN
  483.         Msg$ = "CR"
  484.         CALL SCREENPOP
  485.         LOCATE L,C: PRINT D$;
  486.         EXIT SUB
  487.      END IF
  488.      IF K$ = CHR$(27) THEN
  489.         Msg$ = "ESC"
  490.         CALL SCREENPOP
  491.         EXIT SUB
  492.      END IF
  493.      IF INSTR ("0123456789", K$) THEN '                UPDATED 11-90
  494.         LOCATE L, C '                                    ==========
  495.         D$ = K$ + " -  -" + RIGHT$ (GetDate$, 2) '     If you press a number
  496.         CALL SCREENPOP  '                              key when Rotadate comes
  497.         AdvanceCursor = 1 '                            up, it automatically
  498.         CALL ENTERDATE (D$, Msg$)  '                   switches to regular
  499.         EXIT SUB '                                     keybd entry mode!
  500.      END IF '                                          Thanks for the idea, Al!
  501.    ELSE  '
  502.      K$ = RIGHT$(K$,1)
  503.  
  504.      SELECT CASE ASC(K$)
  505.        CASE &H4B  '                                    left -- back date 1 day
  506.          D$ = WriteDate$(FigDate&(D$) - 1)
  507.        CASE &H4D  '                                right -- advance date 1 day
  508.          D$ = WriteDate$(FigDate&(D$) + 1)
  509.        CASE &H48 '                                                         up
  510.          Msg$ = "Up"
  511.          CALL SCREENPOP
  512.          LOCATE L,C: PRINT D$
  513.          EXIT SUB
  514.        CASE &H50  '                                                        down
  515.          Msg$ = "Down"
  516.          CALL SCREENPOP
  517.          LOCATE L,C: PRINT D$
  518.          EXIT SUB
  519.        CASE &H3B  '
  520.          IF UseF1 THEN Msg$ = "HELP!": CALL SCREENPOP : EXIT SUB
  521.        CASE &H3C  '
  522.          IF UseF2 THEN
  523.            Msg$ = "F2"
  524.            CALL SCREENPOP
  525.            LOCATE L,C: PRINT D$
  526.            EXIT SUB
  527.          END IF
  528.        END SELECT
  529.    END IF
  530.  LOOP
  531.  END SUB
  532. ' -------------------------------------------------------------------
  533.  
  534.  
  535. SUB ENTERTIME  (A$, Msg$) PUBLIC
  536.  LOCAL L, C, Hours, H$, AmPm$
  537.  
  538. EnterTime1:
  539.  DATA 2,":",2,"END"
  540.  RESTORE EnterTime1
  541.  Msg$ = Msg$ + "Num"
  542.  L = CSRLIN: C = POS
  543.  
  544.    CALL ENTERBUNCHES(A$, Msg$)
  545.  
  546.  IF A$ <> "" THEN
  547.     IF VAL (LEFT$(A$,2)) > 24 OR VAL (RIGHT$(A$,2)) > 59 THEN
  548.       A$ = ""
  549.       LOCATE L,C
  550.       GOTO EnterTime1
  551.     END IF
  552.  
  553.     IF RIGHT$ (A$,2) = "  " AND LEFT$ (A$,2) <> "  " THEN
  554.       Hours = VAL(LEFT$ (A$,2))
  555.       IF Hours > 10 THEN
  556.          H$ = LEFT$(A$,2)
  557.       ELSE
  558.         H$ = LEFT$ (STR$(Hours),2)
  559.       END IF
  560.       A$ = H$ + ":00"
  561.       LOCATE L,C: PRINT A$
  562.     END IF
  563.  
  564. AMorPM:
  565.     IF LEFT$(A$,2) <> "  " AND VAL (LEFT$(A$,2)) < 13 THEN
  566. '                                             dialog box to select a.m. or p.m.
  567.        CALL SCREENPUSH
  568. '   Code to write Static Window {AM_PM} to Screen
  569. '        note: created by StatWindow Writer (PWW) from AM_PM.PW
  570.  
  571.        COLOR BoxColor MOD 16, BoxColor \ 16
  572.        LOCATE  9, 24
  573.        PRINT "┌──────────────────────────────────────┐"
  574.        LOCATE  10, 24
  575.        PRINT "│    A - for A.M.                      │";
  576.        LOCATE  11, 24
  577.        PRINT "│    P - for P.M.                      │";
  578.        LOCATE  12, 24
  579.        PRINT "│        [ESC] to Quit                 │";
  580.        LOCATE  13, 24
  581.        PRINT "│              Time entered:           │";
  582.        LOCATE  14, 24
  583.        PRINT "└──────────────────────────────────────┘";
  584.  
  585.        COLOR FldColor MOD 16, FldColor \ 16
  586.        LOCATE  13, 53
  587.        PRINT USING  "\   \";A$;
  588.        COLOR ScrColor MOD 16, ScrColor \ 16
  589.  
  590. '  08-22-1990, 18:40:   end of StatWindow generated code for window {AM_PM}
  591.  
  592.        DO
  593.          AmPm$ = UCASE$ (INKEY$)
  594.        LOOP UNTIL AmPm$ = "A" OR AmPm$ = "P"
  595.        CALL SCREENPOP
  596.        A$ = A$ + " " + MID$ ("a.m.p.m.", 5 + 4*(AmPm$="A"), 4)
  597.        COLOR FldColor MOD 16, FldColor \ 16
  598.        LOCATE L,C: PRINT A$
  599.      END IF
  600.  END IF
  601.  END SUB
  602.  
  603. ' -------------------------------------------------------------------
  604.  
  605. SUB ENTERSSN  (A$, Msg$) PUBLIC
  606.  
  607. EnterSSN1:
  608.  DATA 3," ",2," ",4,"END"
  609.  RESTORE EnterSSN1
  610.  Msg$ = Msg$ + "Num"
  611.  
  612.    CALL ENTERBUNCHES(A$, Msg$)
  613.  
  614. END SUB
  615.  
  616. ' -------------------------------------------------------------------
  617.  
  618.  
  619. SUB ENTERPHONE  (A$, Msg$) PUBLIC
  620.  
  621.  LOCAL L,C
  622.  
  623. EnterPhone1:
  624.  DATA "(",3,") ",3,"-",4," ext. ",5
  625.  DATA END
  626. EShortPhone:
  627.  DATA "(",3,") ",3,"-",4
  628.  DATA END
  629.  LOCAL WithExtension
  630.  
  631.  IF INSTR(Msg$,"NoExt") THEN
  632.      RESTORE EShortPhone
  633.    ELSE
  634.      RESTORE EnterPhone1
  635.      WithExtension = %True
  636.    END IF
  637.  A$ = LTRIM$ (RTRIM$ (A$))
  638.  IF A$ = "" THEN A$ = "("+LocalAreaCode$+")"
  639.  Msg$ = Msg$ + "Num"
  640.  
  641.    CALL ENTERBUNCHES(A$, Msg$)
  642.  
  643.  A$ = LTRIM$ (RTRIM$ (A$))
  644.  IF WithExtension THEN
  645.    IF RIGHT$ (A$,4) = "ext." THEN A$ = LEFT$ (A$,19)  ' if no ext # then trim
  646.    PRINT USING "\"+SPACE$(23)+"\"; A$  '                 off the word "ext."
  647.  ELSE
  648.    PRINT USING "\"+SPACE$(14)+"\"; A$
  649.  END IF
  650.  END SUB  '
  651.  
  652. SUB FASTPHONE (PN$, Msg$) PUBLIC
  653.  LOCAL I$(), L, C, PN0$
  654.  DIM I$ (2)
  655.  L = CSRLIN: C = POS
  656.  LOCATE 25,1: COLOR ScrColor MOD 16, ScrColor \ 16
  657.  I$(1) = "PHONE # ENTRY: Type in the digits only. No hyphens etc. Include the area code"
  658.  I$(2) = "if needed (eg: 5551234 or 7075553456). The computer will add the punctuation."
  659.  CALL SCREENPUSH
  660.  CALL BOXMESSAGE2 (22, 1, 0, I$(), 2, 78)
  661.  PN0$ = PN$
  662.  DO
  663.    Msg$ = "NumUpOut"
  664.    LOCATE L, C: COLOR FldColor MOD 16, FldColor \ 16
  665.  
  666.         CALL ENTERSTRING (PN$, 14, Msg$)
  667.  
  668.    IF Msg$ = "CR" OR Msg$ = "Up" THEN
  669.      PN$ = REMOVE$ (PN$, ANY " /,.-_")
  670.      IF LEFT$  (PN$, 1) = "1" THEN PN$ = MID$ (PN$, 2)
  671.      IF VERIFY (PN$, "0123456789") THEN PN$ = ""
  672.      SELECT CASE LEN (PN$)
  673.        CASE 7
  674.          PN$ = LEFT$ (PN$, 3) + "-" + RIGHT$ (PN$, 4)
  675.        CASE 10
  676.          PN$ = "1-"+ LEFT$(PN$, 3) +"-" +MID$(PN$, 4, 3) +"-"+ RIGHT$ (PN$, 4)
  677.        CASE 0
  678.        CASE ELSE
  679.          PN$ = "error"
  680.      END SELECT
  681.    END IF
  682.  IF Msg$ <> "CR" AND Msg$ <> "Up" AND Msg$ <> "Down" THEN PN$ = PN0$
  683.  LOOP UNTIL PN$ <> "error"
  684.  CALL SCREENPOP
  685.  LOCATE L, C: COLOR FldColor MOD 16, FldColor \ 16
  686.  PRINT USING "\            \"; PN$
  687. END SUB
  688.  
  689.  
  690. ' -------------------------------------------------------------------
  691.  
  692. SUB ENTERBUNCHES (A$, Msg$)
  693.  LOCAL L, C, FLength, Sep$(), Size(), Bunch%, B$, B%, FPos, Opt0$
  694.  DIM Sep$ (20): DIM Size (20)
  695.  Bunch% = 1
  696.  L = CSRLIN: C = POS
  697.  READ B$
  698.  DO UNTIL B$ = "END"
  699.    IF INSTR("123456789",B$) THEN
  700.       Size(Bunch%) = VAL (B$)
  701.       INCR FLength, (LEN(Sep$(Bunch%))+Size(Bunch%))
  702.       INCR Bunch%                   ' get sizes of bunches and separator chrs
  703.    ELSE
  704.       Sep$(Bunch%) = B$
  705.    END IF
  706.    READ B$
  707.  LOOP
  708.  
  709.  A$ = A$ + SPACE$(FLength-LEN(A$))
  710.  
  711.  
  712.  B% = 1
  713.  FPos = 1                              '  this is to move the cursor past a
  714.  IF Msg$ <> "Up" THEN
  715.    DO UNTIL FPos > LEN(A$)
  716. '      check each bunch in the string as it already exists. If it doesn't
  717. '                               contain any blanks, jump to the next one ...
  718.      IF INSTR (MID$ (A$, LEN (Sep$(B%)) + FPos, Size (B%)), " ")  = 0 THEN
  719.        INCR FPos,  LEN(Sep$(B%)) + Size(B%)
  720.        INCR B%                                  ' if it isn't, jump over it ...
  721.      ELSE
  722.        EXIT LOOP
  723.      END IF
  724.   LOOP
  725. '         if the ALL the bunches of characters were found to be already full,
  726. '                             set cursor (FPos) back to the home position (1)
  727.   IF Fpos >= FLength THEN B% = 1: FPos = 1
  728.  END IF
  729.  
  730. '   now the bunch to start with is B% // the starting $ is A$
  731.  
  732.  
  733. TakeEntry:
  734.  LOCATE L,C: PRINT USING "\"+SPACE$(FLength-2)+"\"; A$
  735.  
  736.  Opt0$ = Msg$
  737.  DO UNTIL Size(B%) = 0
  738.    LOCATE L, (C + FPos-1)
  739.    PRINT Sep$(B%);
  740.    Ln = CSRLIN: Col = POS
  741.    Msg$ = Opt0$+"Auto BackOut UpOut"
  742.    B$ = MID$ (A$, FPos+LEN(Sep$(B%)), Size(B%))
  743.  
  744.      CALL ENTERSTRING (B$,Size(B%),Msg$)
  745.  
  746.    MID$(A$,FPos) = Sep$(B%)+B$
  747.  
  748.  SELECT CASE Msg$
  749.  
  750.    CASE "Left"
  751.      IF B% > 1 THEN
  752.        DECR B%
  753.        DECR FPos, Size(B%)+LEN(Sep$(B%))
  754.           END IF
  755.  
  756.    CASE "Up", "ESC", "F2", "HELP!", "Tab", "ShfTab", "CR", "Down"
  757.      EXIT LOOP
  758.  
  759.    CASE "Auto"
  760.      INCR FPos, Size(B%)+LEN(Sep$(B%))
  761.      INCR B%
  762.  
  763.    CASE ELSE
  764.      PRINT "ENTERBUNCHES: Error! Msg$ = "; Msg$; :CALL CloseFiles: STOP
  765.  
  766.  END SELECT
  767.  LOOP
  768.  
  769. BunchDone:
  770.  LOCATE L,C
  771. END SUB  '                                          REM    ENTERBUNCHES
  772.  
  773. SUB PressAKey PUBLIC
  774.  LOCAL Click
  775.  
  776.  LOCATE 20, 58, 0: COLOR 0,7
  777.  PRINT "╔═════════════════╗"                ' pcWrite is great for boxing now!
  778.  LOCATE 21, 58
  779.  PRINT "║   HIT ANY KEY   ║"           ' (always did do a zippy search/replace)
  780.  IF NeedDCon THEN
  781.    LOCATE 22, 58
  782.    PRINT "║ OR CLICK RODENT ║"
  783.    LOCATE 23, 58
  784.    PRINT "║    TO GO ON     ║"
  785.    LOCATE 24, 58
  786.    PRINT "╚═════════════════╝";
  787.  ELSE
  788.    LOCATE 22, 58
  789.    PRINT "║    TO GO ON     ║"
  790.    LOCATE 23, 58
  791.    PRINT "╚═════════════════╝";
  792.  END IF
  793.  
  794.  IF SoundOn THEN PLAY PressAKeyBeep$
  795.  IF NeedDCon THEN
  796.    DO
  797.      CALL Mouse (%ReadRodent, Click, X, Y)
  798.    LOOP UNTIL ((INKEY$ <> "") OR Click)
  799.  ELSE
  800.    DO: LOOP UNTIL INKEY$ <> ""
  801.  END IF
  802.  
  803.  LOCATE ,,1
  804.  
  805.  END SUB
  806. '____________________________________________________________________________
  807.  
  808. FUNCTION GETYESORNO  PUBLIC
  809.    LOCAL X$
  810.    STATIC GhostMice
  811.    PRINT " (y/n) ";
  812.                              $IF NOT %SkipGhostMouse
  813.  
  814.    IF NeedDCon AND GhostMice < 2 THEN '               show the picture of a
  815.      CALL SCREENPUSH '                                mouse as a hint twice ...
  816.      CALL MousePrompt4yn
  817.      INCR GhostMice
  818.      FOR T = 0 TO 5:
  819.        DELAY .25
  820.        CALL Mouse (%ReadRodent, Click, X, Y)
  821.        IF INSTAT OR Click THEN EXIT FOR
  822.      NEXT T
  823.      CALL SCREENPOP
  824.    END IF
  825.                                       $ENDIF
  826.  
  827.    DO WHILE X$ <> "Y" AND X$ <> "N"
  828.      IF NeedDCon THEN
  829.        DO
  830.          CALL Mouse (%ReadRodent, Click, X, Y)
  831.        LOOP UNTIL (INSTAT OR Click)
  832.      ELSE
  833.        Click = %False
  834.        DO: LOOP UNTIL INSTAT
  835.      END IF
  836.      X$ = INKEY$
  837.      X$ = UCASE$(X$)
  838.      IF X$ =  CHR$(0)+CHR$(&H50) THEN X$ = "N" '            down arrow = "NO"
  839.      IF Click = %LeftButton THEN X$ = "Y"
  840.      IF Click = %RightButton THEN X$ = "N"
  841.    LOOP
  842.    PRINT X$;
  843.    GetYesOrNo = (X$ = "Y")
  844.    END FUNCTION
  845.  
  846. SUB ENTERYESNO  (Yes) PUBLIC
  847.  LOCAL Choice$, L, C
  848.  COLOR FldColor MOD 16, FldColor \ 16
  849.  L = CSRLIN
  850.  C = POS
  851.  PRINT "Y"
  852.  LOCATE L, C
  853.  DO
  854.    DO:LOOP UNTIL INSTAT
  855.    Choice$ = INKEY$
  856.    SELECT CASE Choice$
  857.      CASE "y", "Y", CHR$(13)
  858.        PRINT "Y"
  859.        Yes = %True
  860.        EXIT LOOP
  861.      CASE "n", "N", CHR$(27)
  862.        PRINT "N"
  863.        Yes = %False
  864.        EXIT LOOP
  865.      CASE ELSE
  866.        PLAY OopsBeep$
  867.    END SELECT
  868.  LOOP
  869.  END SUB '                                         REM -- ENTERYESNO
  870.  
  871. FUNCTION ROUNDOFF# (N#, Places%)
  872.  SELECT CASE Places%
  873.    CASE 0
  874.      ROUNDOFF# = ROUND (N#, 0)
  875.      EXIT SELECT
  876.    CASE 1
  877.      ROUNDOFF# = ROUND (N#, 1)
  878.      EXIT SELECT
  879.    CASE 2
  880.      ROUNDOFF# = ROUND (N#, 2)
  881.      EXIT SELECT
  882.    CASE 3
  883.      ROUNDOFF# = ROUND (N#, 3)
  884.      EXIT SELECT
  885.    CASE 4
  886.      ROUNDOFF# = ROUND (N#, 4)
  887.  END SELECT
  888. END FUNCTION
  889.  
  890.  
  891. SUB MousePrompt4yn
  892.  
  893.  LOCAL CornerLin, CornerCol, L, C, Att
  894.  L = CSRLIN: C = POS
  895.  CornerLin = MIN (CSRLIN, 17)
  896.  IF POS < 68 THEN
  897.    CornerCol = POS + 2
  898.  ELSE
  899.    CornerCol = 6
  900.  END IF
  901.  COLOR 0, 7
  902.  LOCATE CornerLin, CornerCol: PRINT "╔═══╦═══╗"
  903.  LOCATE          , CornerCol: PRINT "║ Y ║ N ║"
  904.  LOCATE          , CornerCol: PRINT "╠═══╝═══╣"
  905.  LOCATE          , CornerCol: PRINT "║       ║"
  906.  LOCATE          , CornerCol: PRINT "║       ║"
  907.  LOCATE          , CornerCol: PRINT "║       ║"
  908.  LOCATE          , CornerCol: PRINT "╚═══╤═══╝"
  909.  LOCATE          , CornerCol + 4: PRINT "│";
  910.  Att =  SCREEN (L, C, 1)
  911.  COLOR Att MOD 16, Att \ 16
  912.  LOCATE L,C
  913.  
  914.        END SUB
  915.